Developer CD Series 2000 November: Tool Chest/Dev.CD Nov 00 TC Disk 2.toast/pc/sample code/platforms and tools/signals/ufailure.inc1.p

Text File | 2000-09-28 | 9.2 KB | 396 lines

{------------------------------------------------------------------------------
#
#    Apple Macintosh Developer Technical Support
#
#    Exception handling for MPW Pascal, MacApp and MPW C
#
#    UFailure (aka Signals) - “Exceptional code, with a few exceptions.”
#
#    UFailure.inc1.p    -    Pascal source - the IMPLEMENTATION
#
#    Copyright © 1985-1988 Apple Computer, Inc.
#    All rights reserved.
#
#    Versions:    1.00                11/88
#                1.01                06/92
#
#    Components:    CTestSignal.c        November 1, 1988
#                CTestSignal.make    November 1, 1988
#                PTestSignal.p        November 1, 1988
#                PTestSignal.make    November 1, 1988
#                UFailure.p            November 1, 1988
#                UFailure.h            November 1, 1988
#                UFailure.incl.p        November 1, 1988
#                UFailure.a            November 1, 1988
#
#    UFailure (or Signals) is a set of exception handling routines suitable for
#    use with MacApp, MPW C, and MPW Pascal. It is a jazzed-up version of the MacApp
#    UFailure unit. There is a set of C interfaces to it as well.
#
------------------------------------------------------------------------------}


VAR
    {$PUSH}
    {$Z+}    {make gTopHandler accessable to assembly code}
    gTopHandler:        PFailInfo;    {linked list of failure handlers}
     gInitHandler:        ProcPtr;
    {$POP}


PROCEDURE InitUFailure; EXTERNAL;
    { Allocates the heap block for CatchSignals and initializes the global
        variables used by the unit. }

PROCEDURE InitSignals; EXTERNAL;
    { Calls InitUFailure. It also sets up the A6 for the main level of Pascal,
        so it must be called from the outermost level of Pascal. }


FUNCTION CatchSignal: INTEGER; EXTERNAL;
    { Until the procedure which encloses this call returns, this will catch
        subsequent Signal calls, returning the code passed to Signal.  When
        CatchSignal is encountered initially, it returns a code of zero.  These
        calls may "nest"; i.e. you may have multiple CatchSignals in one procedure.
        Each nested CatchSignal call uses 72 bytes of heap space.
        If you signal with SignalMessage and pass in a non-zero message you should use
        CatchHandler instead so you have a way of getting at the message. }


PROCEDURE FreeSignal; EXTERNAL;
    { This undoes the effect of the last CatchSignal.  A Signal will then invoke
        the CatchSignal prior to the last one. }


PROCEDURE Signal(code: INTEGER); EXTERNAL;
    { Returns control to the point of the last CatchSignal.  The program will
        then behave as though that CatchSignal had returned with the code parameter
        supplied to Signal. If CatchHandler is catching, the message parameter will be 0. }


PROCEDURE SignalMessage(code: INTEGER; message: LONGINT); EXTERNAL;
    { Returns control to the point of the last CatchSignal/CatchFailures.
        If CatchFailures is catching, the message parameter will be returned. }


{-----------------------------------+
|    MacApp stuff                    |
+-----------------------------------}


{-----------------------------------+
|    External Declarations            |
+-----------------------------------}
PROCEDURE CatchFailures (VAR fi: FailInfo;
                        PROCEDURE Handler(e: INTEGER; m: LONGINT)); EXTERNAL;

PROCEDURE DoFailure(pf: PFailInfo); EXTERNAL;

{-----------------------------------+
|    CallInitHandler                    |
+-----------------------------------}
PROCEDURE CallInitHandler (error: INTEGER; message: LONGINT; p: ProcPtr);
        INLINE    $205F,        {MOVE.L        (A7)+,A0    }
                $4E90;        {JMP        (A0)        }

{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    FailMemError                    |
+-----------------------------------}
PROCEDURE FailMemError;
VAR
    e:    OSErr;
{$IFC qDebug}
    s:        Str255;
{$ENDC}
BEGIN
    e := MemError;

{$IFC UsingMacApp}
{$IFC qDebug}
    IF gAskFailure AND (e = noErr) AND CanReadLn THEN
        BEGIN
{$%+}
        GetMethodName(%_GetA6+4, s);
{$%-}
        e := ReadInteger(CONCAT('FailMemError called by ', s, '.  Enter return error: '));
        END;
{$ENDC qDebug}
{$ENDC UsingMacApp}

    IF e <> noErr THEN
        Failure(e, 0);
END {FailMemError};


{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    FailNIL                            |
+-----------------------------------}
PROCEDURE FailNIL (p: UNIV Ptr);
BEGIN
    { no check for gAskFailure here, since we do this when objects are created. }
    IF p = NIL THEN
        Failure(memFullErr, 0);
END {FailNIL};


{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    FailNewMessage                    |
+-----------------------------------}
PROCEDURE FailNewMessage (error: INTEGER; oldMessage, newMessage: LONGINT);
BEGIN
    IF oldMessage = 0 THEN
        oldMessage := newMessage;
    Failure(error, oldMessage);
END {FailNewMessage};


{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    FailOSErr                        |
+-----------------------------------}
PROCEDURE FailOSErr (error: INTEGER);

{$IFC qDebug}
VAR
    s:        Str255;
{$ENDC}

BEGIN
{$IFC UsingMacApp}
{$IFC qDebug}
    IF gAskFailure AND (error = noErr) AND CanReadLn THEN
        BEGIN
{$%+}
        GetMethodName(%_GetA6+4, s);
{$%-}
        error := ReadInteger(CONCAT('FailOSErr called by ', s, '.  Enter return error: '));
        END;
{$ENDC qDebug}
{$ENDC UsingMacApp}

    IF error <> noErr THEN
        Failure(error, 0);
END {FailOSErr};


{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    FailResError                    |
+-----------------------------------}
PROCEDURE FailResError;
VAR
    e:    OSErr;
{$IFC qDebug}
    s:        Str255;
{$ENDC}
BEGIN
    e := ResError;

{$IFC UsingMacApp}
{$IFC qDebug}
    IF gAskFailure AND (e = noErr) AND CanReadLn THEN
        BEGIN
{$%+}
        GetMethodName(%_GetA6+4, s);
{$%-}
        e := ReadInteger(CONCAT('FailResError called by ', s, '.  Enter return error: '));
        END;
{$ENDC qDebug}
{$ENDC UsingMacApp}

    IF e <> noErr THEN
        Failure(e, 0);
END {FailResError};


{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    Failure                            |
+-----------------------------------}
PROCEDURE Failure (error: INTEGER; message: LONGINT);
VAR
    pf:     PFailInfo;
    ih:     ProcPtr;
    pc:        LONGINT;
{$IFC UsingMacApp}
{$IFC qDebug}
    cl:     String8;
    me:     String8;
    seg:    INTEGER;
    who:    STRING[17];
{$ENDC qDebug}
{$ENDC UsingMacApp}
BEGIN
    pf := gTopHandler;

    IF pf <> NIL THEN
        BEGIN
{$IFC UsingMacApp}
{$IFC qDebug}
        pc := pf^.whoPC;
        GetProcname(LONGINT(@pc), cl, me);
        who := CONCAT(cl, '.', me);
        IF cl = kSpace8 THEN
            who[9] := ' ';

        Writeln('Failure caught by ', who);
        Writeln('        error = ', error:1, ' message = ', message:1,
                ' (', BSR(message, 16):1, '/', BAND(message, $0000FFFF):1, ')');
{$ENDC qDebug}
{$ENDC UsingMacApp}

    {* RBB removed the line
        gTopHandler := pf^.nextInfo;
      on 9/26/88 since DoFailure calls FreeSignal first thing *}
        pf^.error := error;
        pf^.message := message;
        DoFailure(pf);            {Go execute the failure handler}
        END
    ELSE IF gInitHandler <> NIL THEN
        BEGIN
        ih := gInitHandler;
        gInitHandler := NIL;
        CallInitHandler(error, message, ih);

        ExitToShell;
        END
    ELSE
        BEGIN
{$IFC UsingMacApp}
{$IFC qDebug}
        ProgramBreak('Failure called, but no handler!');
{$ENDC qDebug}
{$ELSEC}
    Debugger;
{$ENDC UsingMacApp}
        END;
END {Failure};


{$IFC UsingMacApp}
{$IFC qDebug}
{$IFC qTrace}{$D+}{$ENDC}
{$S MADebug}
{-----------------------------------+
|    ProgramBreak                    |
+-----------------------------------}
PROCEDURE ProgramBreak (grievance: Str255);
    { ProgramBreak: Your app can call this when it comes to a situation that you do not expect
        and cannot handle gracefully.  It beeps and displays a message.  If called before
        there is a WriteLn window, it calls OBJFail, which goes into an infinite loop.
        Otherwise, it enters our debugger. }
VAR
    synthRec:    RECORD
                mode:        INTEGER;
                triplet:    Tone;
                endTriplet: Tone;
                END;

BEGIN
{$IFC FALSE}
    WITH synthRec, triplet DO
        BEGIN
        mode := swMode;

        count := 445;
        amplitude := 100;
        duration := 25;

        endTriplet.count := 0;
        endTriplet.amplitude := 0;
        endTriplet.duration := 0;
        END;

    StartSound(@synthRec, SIZEOF(synthRec), Pointer(-1));
{$ENDC}
    SysBeep(2);

    WWForceOutput(forceOn, forceUnchanged);
    WriteLn('ProgramBreak: ', grievance);
    WWEndForce;

{$IFC qTrace}
    TRCBreak;
{$ELSEC}
    OBJFail(kFailNone);
{$ENDC}
END {ProgramBreak};
{$IFC qTrace}{$D++}{$ENDC}


{$IFC qTrace}{$D+}{$ENDC}
{$S MADebug}
{-----------------------------------+
|    ProgramReport                    |
+-----------------------------------}
PROCEDURE ProgramReport (grievance: Str255; break: BOOLEAN);

BEGIN
    Writeln(grievance);
    IF break THEN
        TRCBreak;
END {ProgramReport};
{$IFC qTrace}{$D++}{$ENDC}
{$ENDC qDebug}
{$ENDC UsingMacApp}


{$IFC UsingMacApp}
{$S MAInit}
{$IFC qTrace}{$D+}{$ENDC}
{-----------------------------------+
|    SetInitHandler                    |
+-----------------------------------}
PROCEDURE SetInitHandler (handler: ProcPtr);
BEGIN
    gInitHandler := handler;
END {SetInitHandler};
{$IFC qTrace}{$D++}{$ENDC}
{$ENDC UsingMacApp}


{We assume that the programmer passes in the correct FailInfo record; ie. the one that is the
    top of the stack.}
{$IFC UsingMacApp}
{$S MAMain}
{$ENDC}
{-----------------------------------+
|    Success                            |
+-----------------------------------}
PROCEDURE Success (VAR fi: FailInfo);
BEGIN
{$IFC qDebug}
    IF gTopHandler <> @fi THEN
    {$IFC UsingMacApp}
        BEGIN
        Write('gTopHandler = ');
        WritePtr(gTopHandler);
        Write('parameter = ');
        WritePtr(@fi);
        WRITELN;
        ProgramBreak('Problem with Success: too many or too few calls to Success');
        END;
    {$ELSEC UsingMacApp}
        Debugger;
    {$ENDC UsingMacApp}
{$ENDC qDebug}

    gTopHandler := fi.nextInfo;
END {Success};